home *** CD-ROM | disk | FTP | other *** search
/ Super CD / Super CD.iso / geomitri / acad10 / slot.lsp < prev    next >
Lisp/Scheme  |  1988-07-26  |  5KB  |  131 lines
  1. ; **********************************************************************
  2. ;                            SLOT.LSP
  3. ;
  4. ; This routine uses 3dfaces to construct "slots" and "holes"
  5. ; in presentation models that will be rendered with AutoShade.
  6. ; It generates a rectangular edge of invisible faces around
  7. ; the top and bottom of the slot or hole.  This edge makes it
  8. ; much easier to attach adjoining faces to the slot.  To see
  9. ; this rectangular edge set the system variable "splframe" to 1.
  10. ;
  11. ; Written by Training Department - 3/01/88
  12. ; **********************************************************************
  13.  
  14. ;Internal error handler
  15.  
  16. (defun SLTERR (s)                     ; If an error (such as CTRL-C) occurs
  17.                                       ; while this command is active...
  18.    (if (/= s "Function cancelled")
  19.        (princ (strcat "\nError: " s))
  20.    )
  21.    (entdel temp)
  22.    (if undo                           ; Undo 3dfaces for a clean exit
  23.        (progn
  24.           (command)                   ; simulate CTRL-C (cancel 3DFACE cmd)
  25.           (command "UNDO" "E")        ; terminate Undo group
  26.           (princ " ...undoing ")      ; erase partially-drawn stuff
  27.           (command "U")
  28.        )
  29.    )
  30.    (setvar "blipmode" obm)            ; restore saved BLIPMODE
  31.    (setvar "cmdecho" ocmd)            ; restore saved CMDECHO
  32.    (setq *error* olderr)              ; restore old *error* handler
  33.    (princ)
  34. )
  35.  
  36. (defun ADD-TO-SET (/ next)
  37.  (while (setq next (entnext last))
  38.   (ssadd next copy-set)
  39.   (setq last (entnext last))
  40.  )
  41.  (setq last (entlast))
  42. )
  43.  
  44. ; Main program
  45.  
  46. (defun C:SLOT ( / olderr ocmd obm c-elev p-type ip rad 2p depth last
  47.                   temp copy-set ang s-ang rs-ang halfdist one two three
  48.                   four five six seven ur f1 f2 f3 f4 f5 f6 undo)
  49.  (setq olderr  *error*
  50.        *error* slterr)
  51.  (setq ocmd (getvar "cmdecho"))
  52.  (setvar "cmdecho" 0)
  53.  (setq obm (getvar "blipmode"))
  54.  (setq c-elev (getvar "elevation"))
  55.  (command "UNDO" "group")
  56.  (setq p-type (strcase (getstring "\nHole or Slot? H/S <S>: ")))
  57.  (if (= p-type "H")
  58.   (progn
  59.    (initget 17)
  60.    (setq ip (getpoint "\nCenter point: "))
  61.    (initget 7)
  62.    (setq rad (getdist ip "\nRadius: "))
  63.   )
  64.   (progn
  65.    (initget 17)
  66.    (setq ip (getpoint "\nFirst center point of slot: "))
  67.    (initget 7)
  68.    (setq rad (getdist ip "\nSlot radius: "))
  69.    (initget 17)
  70.    (setq 2p (getpoint ip "\nSecond center point of slot: "))
  71.   )
  72.  )
  73.  (if (null 2p) (setq 2p ip))
  74.  (initget 7)
  75.  (setq depth (getdist ip "\nDepth: "))
  76.  (prompt "\nPlease wait . . .")
  77.  (setvar "blipmode" 0)
  78.  (command "point" ip)                 ; temporary node
  79.  (setq last (entlast))
  80.  (setq temp last)
  81.  (setq copy-set (ssadd))              ; initialize copy set
  82.  (setq ang (/ pi 10))
  83.  (setq s-ang (angle ip 2p))
  84.  (setq rs-ang (- s-ang pi))
  85.  (setq halfdist (/ (distance ip 2p) 2))
  86.  (setq one   (polar ip (+ rs-ang (* 0 ang)) rad)) ; calculate edge points
  87.  (setq two   (polar ip (+ rs-ang (* 1 ang)) rad))
  88.  (setq three (polar ip (+ rs-ang (* 2 ang)) rad))
  89.  (setq four  (polar ip (+ rs-ang (* 3 ang)) rad))
  90.  (setq five  (polar ip (+ rs-ang (* 4 ang)) rad))
  91.  (setq six   (polar ip (+ rs-ang (* 5 ang)) rad))
  92.  (setq seven (polar six s-ang halfdist))
  93.  (setq ur    (polar one (- s-ang (/ pi 2)) rad))
  94.  (setq f1 (list (car five) (cadr five) c-elev))
  95.  (setq f2 (list (car five) (cadr five) (+ c-elev depth)))
  96.  (setq f3 (list (car six) (cadr six) (+ c-elev depth)))
  97.  (setq f4 (list (car six) (cadr six) c-elev))
  98.  (setq f5 (list (car seven) (cadr seven) c-elev))
  99.  (setq f6 (list (car seven) (cadr seven) (+ c-elev depth)))
  100.  (command "3dface" "i" one   "i" two   "i" ur "i" ur "") ; draw edge
  101.  (setq undo T)                        ; set undo 3dfaces marker
  102.  (command "3dface" "i" two   "i" three "i" ur "i" ur "")
  103.  (command "3dface" "i" three "i" four  "i" ur "i" ur "")
  104.  (command "3dface" "i" four  "i" five  "i" ur "i" ur "")
  105.  (command "3dface" "i" five  "i" six   "i" ur "i" ur "")
  106.  
  107.  (ADD-TO-SET)
  108.  
  109.  (command "copy" copy-set "" (list 0 0 0) (list 0 0 depth))
  110.  (command "3dface" f6 f5 f4 f3 f2 f1) (command) ; draw vertical faces
  111.  (command "array" "l" "" "c" ip "-18" 5 "y")    ; 1/4 complete
  112.  
  113.  (ADD-TO-SET)
  114.  
  115.  (command "mirror" copy-set "" ip (polar ip s-ang 1) "n")
  116.  
  117.  (ADD-TO-SET)
  118.  
  119.  (command "mirror" copy-set "" (polar ip s-ang halfdist)
  120.                                (polar six s-ang halfdist) "n"
  121.  )
  122.  
  123.  (entdel temp)
  124.  (prompt " done")
  125.  (command "UNDO" "E")                 ; terminate Undo group
  126.  (setvar "blipmode" obm)              ; restore old BLIPMODE
  127.  (setvar "cmdecho" ocmd)              ; restore old CMDECHO
  128.  (setq *error* olderr)                ; restore old *error* handler
  129.  (princ)
  130. )
  131.